home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
yerk 3.66
/
System source
/
Menu
< prev
next >
Wrap
Text File
|
1994-06-24
|
9KB
|
282 lines
\ 5- 7-84 NDI Version 1
\ 6/18/84 CBD Added Draw: and clear in MenuBar
\ 6/27/84 CBD Separated FILL: from INIT:
\ 8/16/84 CBD Non-resource definition
\ 10/25/84 CBD FILL:-> PUT:, SET: -> HILITE:, etc
\ 12/20/84 cbd Added desk accy support
\ 12/20/84 cbd Added menu key support
\ 12/30/85 cdn Expanded AppleMen to handle up to 22 items
\ 9/03/86 cdn Added call DrawMenuBar to enable: & disable:
\ 9/23/86 cdn Fixed opendesk:, saves graph port
\ 9/31/88 rfl added mItem, changed mselect, key:
\ 10/26/89 rfl added menuId, more menus in mbar
\ set now consistent with get,check,uncheck
\ All begin with 1.
\ 5/13/90 rfl added ability to add and remove menus in menubar
\ 5/23/90 rfl added hmenu,pmenu,applemenu
\ 5/30/90 rfl modified enable, disable menubar to work nicer in display
\ 12/24/90 rfl fixed getName: pmenu
\ 5/10/91 rfl added getnew: for use with resource files
\ 5/14/91 rfl addone does not add to menubar if menu already is there
\ 2/25/92 rfl added getName; checkone
\ 6/23/92 rfl removed position: from pmenu; fixed uncheckall:
\ 7/19/92 rfl changed set: to have stack consistent with sarray input to:
\ 11/10/92 rfl changed 'getname: pmenu' to getHItemName, so can use super method
\ 12/21/92 rfl added ability to determine if an item is checked with checked?: method
\ 5/25/93 rfl added remove: to release: and dispose:; release: to getnew: applemen
\ 8/04/93 rfl getText: pmenu now agrees with lastpick (start from 1, not zero) **change propagates
\ 12/27/93 rfl fixed getnew: applemen to behave better on multiple getnew:
\ ( hndl -- ) error if Toolbox object hasn't called new: or getnew:
: ?new dup 0= classerr" 153 ;
0 value theMenu \ the pointer to the selected menu
:CLASS Menu <Super X-Array
Int Resid \ Resource ID of this menu
handle Mhndl \ Handle to menu heap storage
\ ( -- resid )
:M ID: Get: Resid ;M
\ ( resID -- ) store menuID
:M INIT: put: resID ;M
:M PUTRESID: put: resID ;M
\ ( cfa0...cfaN resid -- ) put resid and handlers in menu
:M PUT: Put: ResId Put: Super ;M
\ ( item# -- addr len ) get string for item #
:M GET: { item -- addr len } get: mhndl item makeInt
buf255 +base call GetItem buf255 count ;M
:M GETNAME: ( -- addr len) get: Mhndl >ptr 14 + count ;M
:M GETNEW: 0 int: ResId call getMenu dup 0= ?error 161 put: mHndl ;M
\ ( addr len -- ) Allocate menu with Title
:M NEW: str255 >R 0 Int: resId R> call NewMenu
Put: Mhndl ;M
:M REMOVE: int: resId call deleteMenu ;M
\ ( -- ) Insert the menu in the menu bar
:M INSERT: Get: Mhndl ?new word0 call InsertMenu ;M
\ use this is menu was not read in from a resource file
:M DISPOSE: remove: self get: mHndl call disposMenu clear: mHndl ;M
\ use this if menu read in from resource file instead of dispose:
:M RELEASE: remove: self get: mHndl call ReleaseResource clear: mHndl ;M
\ ( addr len -- ) Append a menu item
:M ADD: Str255 Get: Mhndl ?new
swap call AppendMenu ;M
\ ( type -- ) add all resources of a type
:M ADDRES: get: mhndl swap call AddResMenu ;M
\ ( addr len item# -- ) replace menu item string
:M SET: >r str255 >r get: mhndl ?new
r> r> swap >r makeInt r> call SetItem ;M
\ ( -- ) Remove hiliting on all items
:M NORMAL: word0 call HiliteMenu ;M
:M HILITE: int: resID call hiliteMenu ;M
\ ( item# -- ) Enable a menu item
:M ENABLE: Get: Mhndl over makeInt call EnableItem
0= IF call DrawMenuBar THEN ;M
\ ( item# -- ) Grey and disable an item
:M DISABLE: Get: Mhndl over makeInt call DisableItem
0= IF call DrawMenuBar THEN ;M
\ ( item# -- ) open the desk accy for item#
:M OPENDESK: savePort get: self 2drop
word0 buf255 +base call OpenDeskAcc word0 drop restPort ;M
\ all menu handlers will have item# on stack when they execute
\ ( item# -- ) Execute the code for a menu item
:M EXEC: ^base -> theMenu 1- dup Exec: Super drop Normal: Self ;M
\ ( item# -- )
:M CHECK: Get: Mhndl swap makeInt w 256 call CheckItem ;M
\ ( item# -- )
:M UNCHECK: Get: Mhndl swap makeInt word0 call CheckItem ;M
:M UNCHECKALL: limit 1+ 1 DO i uncheck: self LOOP ;M
:M CHECKONE: ( n --) uncheckall: self check: self ;M
:M CHECKED?: { mitem \ addr -- b }
mitem limit > classerr" 129 \ make sure within limits
get: mhndl >ptr 14 + -> addr \ move to title field in record
addr c@ addr + 1+ -> addr \ move to 1st item pascal string
mitem 0 \ start search for end of mitem string
DO addr c@ addr + 1+ 4+ -> addr LOOP \ moves to end of mitem string
addr 2- c@ 0= IF false ELSE true THEN ;M \ moves back to check byte
\ return the number of items in the menu
:M MITEMS: word0 get: MHndl call countMItems i->l ;M
;CLASS
:CLASS applemenu <super menu
:M EXEC: ( item# --) dup 3 <
IF exec: super ELSE openDesk: super normal: super THEN ;M
\ there is a problem when getnew: applemen is done more than once in an application
\ the DRVR resources are added again and again, making the menu really big and
\ repetative. To protect against this, check to see if there are more items
\ in the menu than the limit of the menu object. If so, the it's ok to add the drvrs.
:M GETNEW: getnew: super mitems: self limit <=
IF 'type DRVR addRes: self THEN ;M
;CLASS
:CLASS hmenu <super menu
:M insert: get: mhndl w -1 call insertMenu ;M
;CLASS
0 value mItem \ global keeping # of last menu item clicked;start1
0 value menuID
\ ( point -- item# menuID ) call menu manager to track a menu selection
: Mselect 0 swap call MenuSelect unpack swap dup -> mItem swap
-> menuID menuID ;
\ 3.11.90 rfl modified getText: for pmenu to support hierarchical. Get: still works
\ The print method for popUpRect always look to the stringvar for printing.
\ it is loaded to the correct string on menu select by the mode value.
\ pmenu knows how to popup when asked, and it keeps track of
\ which item was selected, and it allows for an x,y offset
\ for display purposes
:CLASS pmenu <super hmenu
int type \ 0: 'offset' rel to mouse;1: use 'offset' as absolute
point offset \ if type=0, then MOUSE will be offset from upper left
\ corner of menu.
int lastPick \ refers to item number (starting from 1)
\ determines if popup appears offset to mouse, or at absolute position
:M type: ( n --) put: type ;M
:M popup: ( -- )
0 get: mHndl
get: type
IF int: offset l->g intSwap
ELSE where: fevent unpack gety: offset - swap getx: offset - pack
THEN
int: lastpick call popupmenuselect
unpack -> menuId -> mitem
mitem 0 >
IF get: resid menuId = \ is mouse in popUp?
IF mitem put: lastPick mitem exec: self \ yes
ELSE mitem menuId exec: menubar \ must be hierarchical submenu
THEN
ELSE 0 -> menuid
THEN ;M
\ this is coded to allow for getting the text item of a hierarchical menu
\ attached to the popup
:M getText: ( item# -- addr len)
0 menuId makeInt call getMHandle \ get menuhandle
swap makeint buf255 +base call GetItem \ get text of selected item
buf255 count ;M
:M offset: ( x y -- ) put: offset ;M
\ :M position: ( x y -- ) put: self ;M
:M putitem: ( lastPick -- ) put: lastPick ;M
:M getitem: ( -- lastPick ) get: lastPick ;M
:M getHItemName: ( -- addr len) get: lastPick getText: self ;M
\ inits to relative offset to mouse
:M classinit: 25 9 offset: self classinit: super ;M
;CLASS
\ ( item# -- item#) execute the desk accessory for an item
\ : doDsk 1+ dup openDesk: [ ^base ] ;
2 applemenu applemen
:CLASS mBar <Super Object
26 wordcol IDs
26 ordered-col Menus \ array of menu objects
\ ( -- )
:M DRAW: call DrawMenuBar ;M
\ ( -- )
:M CLEAR: call ClearMenuBar Clear: IDs clear: Menus ;M
:M Menu: ( id -- menu t or f) indexof: ids IF at: menus true ELSE false THEN ;M
:M addone: ( ^menu -- ) dup indexof: Menus not
IF id: [ dup ] add: ids dup add: menus insert: [ ] draw: self
ELSE 2drop
THEN ;M
:M remove: ( ^menu -- ) remove: [ dup ] indexof: menus
IF dup remove: menus remove: ids THEN draw: self ;M
\ Add menu objects in stream to the MenuBar object
\ ( ^men0...^menN #menus -- )
:M ADD: 0
DO add: Menus Id: [ I at: menus ] Add: IDs
LOOP ;M
\ ( -- ) Insert menus in Toolbox MenuBar list
:M NEW: Size: IDs 0
DO insert: [ Size: IDs 1- i- at: Menus ]
LOOP Draw: Self ;M
:M GETNEW: size: Menus 0 DO getnew: [ i at: Menus ] LOOP ;M
\ ( men0...menN #menus -- )
:M INIT: Clear: self Add: Self getnew: self New: self ;M
\ ( men0...menN #menus -- ) - use with mload module
\ :M MINIT: Clear: self Add: Self New: self ;M
\ ( item# MenuID -- )
:M EXEC: dup 0>
IF IndexOf: IDs
IF Exec: [ at: Menus ] THEN
ELSE 2drop
THEN ;M \ Execute item in menu
\ ( -- )
:M CLICK: Where: fEvent MSelect Exec: Self ;M
\ ( chr -- ) handle a possible menu key selection
:M KEY: 0 swap makeInt call MenuKey unpack -> menuID -> mItem
mItem menuID exec: self ;M
\ Enable all menus in the Menu Bar
:M ENABLE: Size: IDs 0
DO I at: menus 2+ @ word0 call enableItem LOOP Draw: Self ;M
:M DISABLE: Size: IDs 0
DO i at: Menus 2+ @ word0 call disableItem LOOP Draw: Self ;M
;CLASS
\ Define the default menu bar for applications
mBar MenuBar